home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / src-elk / math.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-11-13  |  17.5 KB  |  782 lines
  1. /* Generic math functions
  2.  * modified (zilla)
  3.  * Elk math has several characteristics which are altered
  4.  * as follows:
  5.  *- (/ x y) when both x,y are integer is treated as if x,y are both
  6.  *  real, e.g. (/ 5 3) => 1.6666.  Xscheme and Scm also act this way;
  7.  *  vscm has (/ 5 3) => 1 (integer).
  8.  *  ZELK_INTEGER_DIV changed this so that (/ 5 3) => 1 (as in C).
  9.  *
  10.  *- Real numbers equal to integers become integers, 
  11.  *  e.g. (/ 6. 3.) => 2 (integer); (type 2.0) => integer
  12.  *  ZELK_CONTAGIOUS_FLT makes floats 'contagious'.
  13.  */
  14.  
  15. #include <math.h>
  16. #include <errno.h>
  17.  
  18. #include "scheme.h"
  19.  
  20. extern int errno;
  21.  
  22. #if ZELK
  23. # include <zelk.h>
  24. #endif
  25.  
  26. Object Generic_Multiply(), Generic_Divide();
  27.  
  28. Init_Math () {
  29. #ifdef RANDOM
  30.     srandom (getpid ());
  31. #else
  32.     srand (getpid ());
  33. #endif
  34. }
  35.  
  36. Object Make_Fixnum (n) register n; {
  37.     Object num;
  38.  
  39.     SET(num, T_Fixnum, n);
  40.     return num;
  41. }
  42.  
  43. Object Make_Integer (n) register n; {
  44.     if (FIXNUM_FITS(n))
  45.     return Make_Fixnum (n);
  46.     else
  47.     return Integer_To_Bignum (n);
  48. }
  49.  
  50. Object Make_Unsigned (n) register unsigned n; {
  51.     if (FIXNUM_FITS_UNSIGNED(n))
  52.     return Make_Fixnum (n);
  53.     else
  54.     return Unsigned_To_Bignum (n);
  55. }
  56.  
  57. Object Fixnum_To_String (x, radix) Object x; {
  58.     char buf[32];
  59.     register char *p;
  60.     register n = FIXNUM(x), neg = 0;
  61.  
  62.     if (n == 0)
  63.     return Make_String ("0", 1);
  64.     if (n < 0) {
  65.     neg++;
  66.     n = -n;
  67.     }
  68.     p = buf+31;
  69.     *p = '\0';
  70.     while (n > 0) {
  71.     *--p = '0' + n % radix;
  72.     if (*p > '9')
  73.         *p = 'A' + (*p - '9') - 1;
  74.     n /= radix;
  75.     }
  76.     if (neg)
  77.     *--p = '-';
  78.     return Make_String (p, strlen (p));
  79. }
  80.  
  81. Object Flonum_To_String (x) Object x; {
  82.     char buf[32];
  83.  
  84.     sprintf (buf, FLONUM_FORMAT, FLONUM(x)->val);
  85.     return Make_String (buf, strlen (buf));
  86. }
  87.  
  88. Object P_Number_To_String (argc, argv) Object *argv; {
  89.     int radix = 10;
  90.     Object x = argv[0];
  91.  
  92.     if (argc == 2) {
  93.     radix = Get_Integer (argv[1]);
  94.     switch (radix) {
  95.     case 2: case 8: case 10: case 16:
  96.         break;
  97.     default:
  98.         Primitive_Error ("invalid radix: ~s", argv[1]);
  99.     }
  100.     }
  101.     switch (TYPE(x)) {
  102.     case T_Fixnum:
  103.     return Fixnum_To_String (x, radix);
  104.     case T_Bignum:
  105.     return Bignum_To_String (x, radix);
  106.     case T_Flonum:
  107.     if (radix != 10)
  108.         Primitive_Error ("radix for reals must be 10");   /* bleah! */
  109.     return Flonum_To_String (x);
  110.     }
  111.     /*NOTREACHED*/
  112. }
  113.  
  114. Get_Integer (x) Object x; {
  115.     switch (TYPE(x)) {
  116.     case T_Fixnum:
  117.     return FIXNUM(x);
  118.     case T_Bignum:
  119.     return Bignum_To_Integer (x);
  120.     default:
  121.     Wrong_Type (x, T_Fixnum);
  122.     }
  123.     /*NOTREACHED*/
  124. }
  125.  
  126. Get_Index (n, obj) Object n, obj; {
  127.     register size, i;
  128.  
  129.     i = Get_Integer (n);
  130.     size = TYPE(obj) == T_Vector ? VECTOR(obj)->size : STRING(obj)->size;
  131.     if (i < 0 || i >= size)
  132.     Range_Error (n);
  133.     return i;
  134. }
  135.  
  136. Object Make_Reduced_Flonum (d) double d; {
  137.     Object num;
  138.     int expo;
  139.  
  140. #if (!ZELK_CONTAGIOUS_FLT)
  141.     if (floor (d) == d) {
  142.     if (d == 0)
  143.         return Zero;
  144.     (void)frexp (d, &expo);
  145.     if (expo <= VALBITS-1)
  146.         return Make_Fixnum ((int)d);
  147.     }
  148. #endif
  149.     num = Alloc_Object (sizeof (struct S_Flonum), T_Flonum, 0);
  150.     FLONUM(num)->tag = Null;
  151.     FLONUM(num)->val = d;
  152.     return num;
  153. }
  154.  
  155. Object Fixnum_Multiply (a, b) {
  156.     register unsigned aa = a;
  157.     register unsigned ab = b;
  158.     register unsigned prod, prod2;
  159.     register sign = 1;
  160.     if (a < 0) {
  161.     aa = -a;
  162.     sign = -1;
  163.     }
  164.     if (b < 0) {
  165.     ab = -b;
  166.     sign = -sign;
  167.     }
  168.     prod = (aa & 0xFFFF) * (ab & 0xFFFF);
  169.     if (aa & 0xFFFF0000) {
  170.     if (ab & 0xFFFF0000)
  171.         return Null;
  172.     prod2 = (aa >> 16) * ab;
  173.     } else {
  174.     prod2 = aa * (ab >> 16);
  175.     }
  176.     prod2 += prod >> 16;
  177.     prod &= 0xFFFF;
  178.     if (prod2 > (1 << (VALBITS - 1 - 16)) - 1) {
  179.     if (sign == 1 || prod2 != (1 << (VALBITS - 1 - 16)) || prod != 0)
  180.         return Null;
  181.     return Make_Fixnum (-SIGNBIT);
  182.     }
  183.     prod += prod2 << 16;
  184.     if (sign == -1)
  185.     prod = - prod;
  186.     return Make_Fixnum (prod);
  187. }
  188.  
  189. Object P_Integerp (x) Object x; {
  190.     return TYPE(x) == T_Fixnum || TYPE(x) == T_Bignum ? True : False;
  191. }
  192.  
  193. Object P_Rationalp (x) Object x; {
  194.     return P_Integerp (x);
  195. }
  196.  
  197. Object P_Realp (x) Object x; {
  198.     register t = TYPE(x);
  199.     return t == T_Flonum || t == T_Fixnum  || t == T_Bignum ? True : False;
  200. }
  201.  
  202. Object P_Complexp (x) Object x; {
  203.     return P_Realp (x);
  204. }
  205.  
  206. Object P_Numberp (x) Object x; {
  207.     return P_Complexp (x);
  208. }
  209.  
  210. #define General_Generic_Predicate(prim,op,bigop) Object prim (x) Object x; {\
  211.     register ret;\
  212.     Check_Number (x);\
  213.     switch (TYPE(x)) {\
  214.     case T_Flonum:\
  215.     ret = FLONUM(x)->val op 0; break;\
  216.     case T_Fixnum:\
  217.     ret = FIXNUM(x) op 0; break;\
  218.     case T_Bignum:\
  219.     ret = bigop (x); break;\
  220.     }\
  221.     return ret ? True : False;\
  222. }
  223.  
  224. General_Generic_Predicate (P_Zerop, ==, Bignum_Zero)
  225. General_Generic_Predicate (P_Negativep, <, Bignum_Negative)
  226. General_Generic_Predicate (P_Positivep, >, Bignum_Positive)
  227.  
  228. Object P_Evenp (x) Object x; {
  229.     register ret;
  230.  
  231.     Check_Integer (x);
  232.     switch (TYPE(x)) {
  233.     case T_Fixnum:
  234.     ret = !(FIXNUM(x) & 1); break;
  235.     case T_Bignum:
  236.     ret = Bignum_Even (x); break;
  237.     }
  238.     return ret ? True : False;
  239. }
  240.  
  241. Object P_Oddp (x) Object x; {
  242.     Object tmp;
  243.     tmp = P_Evenp (x);
  244.     return EQ(tmp,True) ? False : True;
  245. }
  246.  
  247. Object P_Exactp (x) Object x; {
  248.     Check_Number (x);
  249.     return False;
  250. }
  251.  
  252. Object P_Inexactp (x) Object x; {
  253.     Check_Number (x);
  254.     return True;
  255. }
  256.  
  257. #define General_Generic_Compare(name,op,bigop) name (x, y) Object x, y; {\
  258.     Object b; register ret;\
  259.     GC_Node;\
  260.     \
  261.     switch (TYPE(x)) {\
  262.     case T_Fixnum:\
  263.     switch (TYPE(y)) {\
  264.     case T_Fixnum:\
  265.         return FIXNUM(x) op FIXNUM(y);\
  266.     case T_Flonum:\
  267.         return FIXNUM(x) op FLONUM(y)->val;\
  268.     case T_Bignum:\
  269.         GC_Link (y);\
  270.         b = Integer_To_Bignum (FIXNUM(x));\
  271.         ret = bigop (b, y);\
  272.         GC_Unlink;\
  273.         return ret;\
  274.     }\
  275.     case T_Flonum:\
  276.     switch (TYPE(y)) {\
  277.     case T_Fixnum:\
  278.         return FLONUM(x)->val op FIXNUM(y);\
  279.     case T_Flonum:\
  280.         return FLONUM(x)->val op FLONUM(y)->val;\
  281.     case T_Bignum:\
  282.         return FLONUM(x)->val op Bignum_To_Double (y);\
  283.     }\
  284.     case T_Bignum:\
  285.     switch (TYPE(y)) {\
  286.     case T_Fixnum:\
  287.         GC_Link (x);\
  288.         b = Integer_To_Bignum (FIXNUM(y));\
  289.         ret = bigop (x, b);\
  290.         GC_Unlink;\
  291.         return ret;\
  292.     case T_Flonum:\
  293.         return Bignum_To_Double (x) op FLONUM(y)->val;\
  294.     case T_Bignum:\
  295.         return bigop (x, y);\
  296.     }\
  297.     }\
  298.     /*NOTREACHED*/ /* ...but lint never sees it */\
  299. }
  300.  
  301. General_Generic_Compare (Generic_Equal,      ==, Bignum_Equal)
  302. General_Generic_Compare (Generic_Less,        <, Bignum_Less)
  303. General_Generic_Compare (Generic_Greater,     >, Bignum_Greater)
  304. General_Generic_Compare (Generic_Eq_Less,    <=, Bignum_Eq_Less)
  305. General_Generic_Compare (Generic_Eq_Greater, >=, Bignum_Eq_Greater)
  306.  
  307. Object General_Compare (argc, argv, op) Object *argv; register (*op)(); {
  308.     register i;
  309.  
  310.     Check_Number (argv[0]);
  311.     for (i = 1; i < argc; i++) {
  312.     Check_Number (argv[i]);
  313.     if (!(*op) (argv[i-1], argv[i]))
  314.         return False;
  315.     }
  316.     return True;
  317. }
  318.  
  319. Object P_Generic_Equal (argc, argv) Object *argv; {
  320.     return General_Compare (argc, argv, Generic_Equal);
  321. }
  322.  
  323. Object P_Generic_Less (argc, argv) Object *argv; {
  324.     return General_Compare (argc, argv, Generic_Less);
  325. }
  326.  
  327. Object P_Generic_Greater (argc, argv) Object *argv; {
  328.     return General_Compare (argc, argv, Generic_Greater);
  329. }
  330.  
  331. Object P_Generic_Eq_Less (argc, argv) Object *argv; {
  332.     return General_Compare (argc, argv, Generic_Eq_Less);
  333. }
  334.  
  335. Object P_Generic_Eq_Greater (argc, argv) Object *argv; {
  336.     return General_Compare (argc, argv, Generic_Eq_Greater);
  337. }
  338.  
  339. #define General_Generic_Operator(name,op,bigop) Object name (x, y)\
  340.     Object x, y; {\
  341.     Object b1, b2, ret; register i;\
  342.     GC_Node2;\
  343.     \
  344.     switch (TYPE(x)) {\
  345.     case T_Fixnum:\
  346.     switch (TYPE(y)) {\
  347.     case T_Fixnum:\
  348.         i = FIXNUM(x) op FIXNUM(y);\
  349.         if (FIXNUM_FITS(i))\
  350.         return Make_Fixnum (i);\
  351.         b1 = b2 = Null;\
  352.         GC_Link2 (b1, b2);\
  353.         b1 = Integer_To_Bignum (FIXNUM(x));\
  354.         b2 = Integer_To_Bignum (FIXNUM(y));\
  355.         ret = bigop (b1, b2);\
  356.         GC_Unlink;\
  357.         return ret;\
  358.     case T_Flonum:\
  359.         return Make_Reduced_Flonum (FIXNUM(x) op FLONUM(y)->val);\
  360.     case T_Bignum:\
  361.         GC_Link (y);\
  362.         b1 = Integer_To_Bignum (FIXNUM(x));\
  363.         ret = bigop (b1, y);\
  364.         GC_Unlink;\
  365.         return ret;\
  366.     }\
  367.     case T_Flonum:\
  368.     switch (TYPE(y)) {\
  369.     case T_Fixnum:\
  370.         return Make_Reduced_Flonum (FLONUM(x)->val op FIXNUM(y));\
  371.     case T_Flonum:\
  372.         return Make_Reduced_Flonum (FLONUM(x)->val op FLONUM(y)->val);\
  373.     case T_Bignum:\
  374.         return Make_Reduced_Flonum (FLONUM(x)->val op\
  375.         Bignum_To_Double (y));\
  376.     }\
  377.     case T_Bignum:\
  378.     switch (TYPE(y)) {\
  379.     case T_Fixnum:\
  380.         GC_Link (x);\
  381.         b1 = Integer_To_Bignum (FIXNUM(y));\
  382.         ret = bigop (x, b1);\
  383.         GC_Unlink;\
  384.         return ret;\
  385.     case T_Flonum:\
  386.         return Make_Reduced_Flonum (Bignum_To_Double (x) op\
  387.         FLONUM(y)->val);\
  388.     case T_Bignum:\
  389.         return bigop (x, y);\
  390.     }\
  391.     }\
  392.     /*NOTREACHED*/ /* ...but lint never sees it */\
  393. }
  394.  
  395. General_Generic_Operator (Generic_Plus,      +, Bignum_Plus)
  396. General_Generic_Operator (Generic_Minus,     -, Bignum_Minus)
  397.  
  398. Object P_Inc (x) Object x; {
  399.     Check_Number (x);
  400.     return Generic_Plus (x, One);
  401. }
  402.  
  403. Object P_Dec (x) Object x; {
  404.     Check_Number (x);
  405.     return Generic_Minus (x, One);
  406. }
  407.  
  408. Object General_Operator (argc, argv, start, op) Object *argv, start;
  409.     register Object (*op)(); {
  410.     register i;
  411.     Object accum;
  412.  
  413.     if (argc > 0)
  414.     Check_Number (argv[0]);
  415.     accum = start;
  416.     switch (argc) {
  417.     case 0:
  418.     break;
  419.     case 1:
  420.     accum = (*op) (accum, argv[0]); break;
  421.     default:
  422.     for (accum = argv[0], i = 1; i < argc; i++) {
  423.         Check_Number (argv[i]);
  424.         accum = (*op) (accum, argv[i]);
  425.     }
  426.     }
  427.     return accum;
  428. }
  429.  
  430. Object P_Generic_Plus (argc, argv) Object *argv; {
  431.     return General_Operator (argc, argv, Zero, Generic_Plus);
  432. }
  433.  
  434. Object P_Generic_Minus (argc, argv) Object *argv; {
  435.     return General_Operator (argc, argv, Zero, Generic_Minus);
  436. }
  437.  
  438. Object P_Generic_Multiply (argc, argv) Object *argv; {
  439.     return General_Operator (argc, argv, One, Generic_Multiply);
  440. }
  441.  
  442. Object P_Generic_Divide (argc, argv) Object *argv; {
  443.     return General_Operator (argc, argv, One, Generic_Divide);
  444. }
  445.  
  446. Object Generic_Multiply (x, y) Object x, y; {
  447.     Object b, ret;
  448.  
  449.     switch (TYPE(x)) {
  450.     case T_Fixnum:
  451.     switch (TYPE(y)) {
  452.     case T_Fixnum:
  453.         ret = Fixnum_Multiply (FIXNUM(x), FIXNUM(y));
  454.         if (Nullp (ret)) {
  455.         b = Integer_To_Bignum (FIXNUM(x));
  456.         return Bignum_Fixnum_Multiply (b, y);
  457.         }
  458.         return ret;
  459.     case T_Flonum:
  460.         return Make_Reduced_Flonum (FIXNUM(x) * FLONUM(y)->val);
  461.     case T_Bignum:
  462.         return Bignum_Fixnum_Multiply (y, x);
  463.     }
  464.     case T_Flonum:
  465.     switch (TYPE(y)) {
  466.     case T_Fixnum:
  467.         return Make_Reduced_Flonum (FLONUM(x)->val * FIXNUM(y));
  468.     case T_Flonum:
  469.         return Make_Reduced_Flonum (FLONUM(x)->val * FLONUM(y)->val);
  470.     case T_Bignum:
  471.         return Make_Reduced_Flonum (FLONUM(x)->val * Bignum_To_Double (y));
  472.     }
  473.     case T_Bignum:
  474.     switch (TYPE(y)) {
  475.     case T_Fixnum:
  476.         return Bignum_Fixnum_Multiply (x, y);
  477.     case T_Flonum:
  478.         return Make_Reduced_Flonum (Bignum_To_Double (x) * FLONUM(y)->val);
  479.     case T_Bignum:
  480.         return Bignum_Multiply (x, y);
  481.     }
  482.     }
  483.     /*NOTREACHED*/
  484. }
  485.  
  486. Object Generic_Divide (x, y) Object x, y; {
  487.     register t = TYPE(y);
  488.     Object b, ret;
  489.     GC_Node2;
  490.  
  491.     if (t == T_Fixnum ? FIXNUM(y) == 0 :
  492.     (t == T_Flonum ? FLONUM(y) == 0 : Bignum_Zero (y)))
  493.     Range_Error (y);
  494.     switch (TYPE(x)) {
  495.     case T_Fixnum:
  496.     switch (t) {
  497.     case T_Fixnum:
  498. # if ZELK_INTEGER_DIV
  499.             return Make_Integer( FIXNUM(x) / FIXNUM(y) );
  500. # else
  501.         return Make_Reduced_Flonum ((double)FIXNUM(x) / (double)FIXNUM(y));
  502. # endif
  503.     case T_Flonum:
  504.         return Make_Reduced_Flonum ((double)FIXNUM(x) / FLONUM(y)->val);
  505.     case T_Bignum:
  506.         GC_Link (y);
  507.         b = Integer_To_Bignum (FIXNUM(x));
  508.         ret = Bignum_Divide (b, y);
  509.         GC_Unlink;
  510.         if (EQ(Cdr (ret),Zero))
  511.         return Car (ret);
  512.         return Make_Reduced_Flonum ((double)FIXNUM(x) /
  513.             Bignum_To_Double (y));
  514.     }
  515.     case T_Flonum:
  516.     switch (t) {
  517.     case T_Fixnum:
  518.         return Make_Reduced_Flonum (FLONUM(x)->val / (double)FIXNUM(y));
  519.     case T_Flonum:
  520.         return Make_Reduced_Flonum (FLONUM(x)->val / FLONUM(y)->val);
  521.     case T_Bignum:
  522.         return Make_Reduced_Flonum (FLONUM(x)->val / Bignum_To_Double (y));
  523.     }
  524.     case T_Bignum:
  525.     switch (t) {
  526.     case T_Fixnum:
  527.         GC_Link (x);
  528.         ret = Bignum_Fixnum_Divide (x, y);
  529.         GC_Unlink;
  530.         if (EQ(Cdr (ret),Zero))
  531.         return Car (ret);
  532. # if ZELK_INTEGER_DIV
  533.             return Car(ret);
  534. # else
  535.         return Make_Reduced_Flonum (Bignum_To_Double (x) /
  536.             (double)FIXNUM(y));
  537. # endif
  538.     case T_Flonum:
  539.         return Make_Reduced_Flonum (Bignum_To_Double (x) / FLONUM(y)->val);
  540.     case T_Bignum:
  541.         GC_Link2 (x, y);
  542.         ret = Bignum_Divide (x, y);
  543.         GC_Unlink;
  544.         if (EQ(Cdr (ret),Zero))
  545.         return Car (ret);
  546. # if ZELK_INTEGER_DIV
  547.             return Car(ret);
  548. # else 
  549.         return Make_Reduced_Flonum (Bignum_To_Double (x) /
  550.             Bignum_To_Double (y));
  551. # endif
  552.     }
  553.     }
  554.     /*NOTREACHED*/
  555. }
  556.  
  557. Object P_Abs (x) Object x; {
  558.     register i;
  559.  
  560.     Check_Number (x);
  561.     switch (TYPE(x)) {
  562.     case T_Fixnum:
  563.     i = FIXNUM(x);
  564.     return i < 0 ? Make_Integer (-i) : x;
  565.     case T_Flonum:
  566.     return Make_Reduced_Flonum (fabs (FLONUM(x)->val));
  567.     case T_Bignum:
  568.     return Bignum_Abs (x);
  569.     }
  570.     /*NOTREACHED*/
  571. }
  572.  
  573. Object General_Integer_Divide (x, y, rem) Object x, y; {
  574.     register fx = FIXNUM(x), fy = FIXNUM(y);
  575.     Object b, ret;
  576.     GC_Node;
  577.  
  578.     Check_Integer (x);
  579.     Check_Integer (y);
  580.     if (TYPE(y) == T_Fixnum ? FIXNUM(y) == 0 : Bignum_Zero (y))
  581.     Range_Error (y);
  582.     switch (TYPE(x)) {
  583.     case T_Fixnum:
  584.     switch (TYPE(y)) {
  585.     case T_Fixnum:
  586.         return Make_Fixnum (rem ? (fx % fy) : (fx / fy));
  587.     case T_Bignum:
  588.         GC_Link (y);
  589.         b = Integer_To_Bignum (fx);
  590.         GC_Unlink;
  591.         ret = Bignum_Divide (b, y);
  592. done:
  593.         return rem ? Cdr (ret) : Car (ret);
  594.     }
  595.     case T_Bignum:
  596.     switch (TYPE(y)) {
  597.     case T_Fixnum:
  598.         ret = Bignum_Fixnum_Divide (x, y);
  599.         goto done;
  600.     case T_Bignum:
  601.         ret = Bignum_Divide (x, y);
  602.         goto done;
  603.     }
  604.     }
  605.     /*NOTREACHED*/
  606. }
  607.  
  608. Object P_Quotient (x, y) Object x, y; {
  609.     return General_Integer_Divide (x, y, 0);
  610. }
  611.  
  612. Object P_Remainder (x, y) Object x, y; {
  613.     return General_Integer_Divide (x, y, 1);
  614. }
  615.  
  616. Object P_Modulo (x, y) Object x, y; {
  617.     Object rem, xneg, yneg;
  618.     GC_Node2;
  619.  
  620.     GC_Link2 (x, y);
  621.     rem = General_Integer_Divide (x, y, 1);
  622.     xneg = P_Negativep (x);
  623.     yneg = P_Negativep (y);
  624.     if (!EQ(xneg,yneg))
  625.     rem = Generic_Plus (rem, y);
  626.     GC_Unlink;
  627.     return rem;
  628. }
  629.  
  630. Object gcd (x, y) Object x, y; {
  631.     Object r, z;
  632.     GC_Node2;
  633.  
  634.     Check_Integer (x);
  635.     Check_Integer (y);
  636.     GC_Link2 (x, y);
  637.     while (1) {
  638.     z = P_Zerop (x);
  639.     if (EQ(z,True)) {
  640.         r = y;
  641.         break;
  642.     }
  643.     z = P_Zerop (y);
  644.     if (EQ(z,True)) {
  645.         r = x;
  646.         break;
  647.     }
  648.     r = General_Integer_Divide (x, y, 1);
  649.     x = y;
  650.     y = r;
  651.     }
  652.     GC_Unlink;
  653.     return r;
  654. }
  655.  
  656. Object P_Gcd (argc, argv) Object *argv; {
  657.     return P_Abs (General_Operator (argc, argv, Zero, gcd));
  658. }
  659.  
  660. Object lcm (x, y) Object x, y; {
  661.     Object ret, p, z;
  662.     GC_Node3;
  663.  
  664.     ret = Null;
  665.     GC_Link3 (x, y, ret);
  666.     ret = gcd (x, y);
  667.     z = P_Zerop (ret);
  668.     if (!EQ(z,True)) {
  669.     p = Generic_Multiply (x, y);
  670.     ret = General_Integer_Divide (p, ret, 0);
  671.     }
  672.     GC_Unlink;
  673.     return ret;
  674. }
  675.  
  676. Object P_Lcm (argc, argv) Object *argv; {
  677.     return P_Abs (General_Operator (argc, argv, One, lcm));
  678. }
  679.  
  680. #define General_Conversion(name,op) Object name (x) Object x; {\
  681.     double d; int expo;\
  682.     \
  683.     Check_Number (x);\
  684.     if (TYPE(x) != T_Flonum)\
  685.     return x;\
  686.     d = op (FLONUM(x)->val);\
  687.     (void)frexp (d, &expo);\
  688.     return (expo <= VALBITS-1) ? Make_Fixnum ((int)d) : Double_To_Bignum (d);\
  689. }
  690.  
  691. #define trunc(x) (x)
  692. #define round(x) ((x) >= 0 ? (x) + 0.5 : (x) - 0.5)
  693.  
  694. General_Conversion (P_Floor, floor)
  695. General_Conversion (P_Ceiling, ceil)
  696. General_Conversion (P_Truncate, trunc)
  697. General_Conversion (P_Round, round)
  698.  
  699. double Get_Double (x) Object x; {
  700.     Check_Number (x);
  701.     switch (TYPE(x)) {
  702.     case T_Fixnum:
  703.     return (double)FIXNUM(x);
  704.     case T_Flonum:
  705.     return FLONUM(x)->val;
  706.     case T_Bignum:
  707.     return Bignum_To_Double (x);
  708.     }
  709.     /*NOTREACHED*/
  710. }
  711.  
  712. Object General_Function (x, y, fun) Object x, y; double (*fun)(); {
  713.     double d, ret;
  714.  
  715.     d = Get_Double (x);
  716.     errno = 0;
  717.     if (Nullp (y))
  718.     ret = (*fun) (d);
  719.     else
  720.     ret = (*fun) (d, Get_Double (y));
  721.     if (errno == ERANGE || errno == EDOM)
  722.     Range_Error (x);
  723.     return Make_Reduced_Flonum (ret);
  724. }
  725.  
  726. Object P_Sqrt (x) Object x; { return General_Function (x, Null, sqrt); }
  727.  
  728. Object P_Exp (x) Object x; { return General_Function (x, Null, exp); }
  729.  
  730. Object P_Log (x) Object x; { return General_Function (x, Null, log); }
  731.  
  732. Object P_Sin (x) Object x; { return General_Function (x, Null, sin); }
  733.  
  734. Object P_Cos (x) Object x; { return General_Function (x, Null, cos); }
  735.  
  736. Object P_Tan (x) Object x; { return General_Function (x, Null, tan); }
  737.  
  738. Object P_Asin (x) Object x; { return General_Function (x, Null, asin); }
  739.  
  740. Object P_Acos (x) Object x; { return General_Function (x, Null, acos); }
  741.  
  742. Object P_Atan (argc, argv) Object *argv; {
  743.     register a2 = argc == 2;
  744.     return General_Function (argv[0], a2 ? argv[1] : Null, a2 ? 
  745.     (double(*)())atan2 : (double(*)())atan);
  746. }
  747.  
  748. Object Min (x, y) Object x, y; {
  749.     return Generic_Less (x, y) ? x : y;
  750. }
  751.  
  752. Object Max (x, y) Object x, y; {
  753.     return Generic_Less (x, y) ? y : x;
  754. }
  755.  
  756. Object P_Min (argc, argv) Object *argv; {
  757.     return General_Operator (argc, argv, argv[0], Min);
  758. }
  759.  
  760. Object P_Max (argc, argv) Object *argv; {
  761.     return General_Operator (argc, argv, argv[0], Max);
  762. }
  763.  
  764. Object P_Random () {
  765. #ifdef RANDOM
  766.     extern long random();
  767.     return Make_Integer ((int)random ());
  768. #else
  769.     return Make_Integer (rand ());
  770. #endif
  771. }
  772.  
  773. Object P_Srandom (x) Object x; {
  774.     Check_Integer (x);
  775. #ifdef RANDOM
  776.     srandom (Get_Integer (x));
  777. #else
  778.     srand (Get_Integer (x));
  779. #endif
  780.     return x;
  781. }
  782.